home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpc09905c.lha / fpc / utils / dumpppu.pp < prev    next >
Text File  |  1998-09-21  |  28KB  |  802 lines
  1. {****************************************************************************
  2.  
  3.     $Id: dumpppu.pp,v 1.7 1998/08/12 12:17:07 carl Exp $
  4.  
  5.     Dumps the contents of a FPC unit file (PPU File)
  6.     Copyright (c) 1995,97 by Florian Klaempfl and Michael Van Canneyt
  7.  
  8.     Members of the FPC Development Team
  9.  
  10.     This program is free software; you can redistribute it and/or modify
  11.     it under the terms of the GNU General Public License as published by
  12.     the Free Software Foundation; either version 2 of the License, or
  13.     (at your option) any later version.
  14.  
  15.     This program is distributed in the hope that it will be useful,
  16.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.     GNU General Public License for more details.
  19.  
  20.     You should have received a copy of the GNU General Public License
  21.     along with this program; if not, write to the Free Software
  22.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24.  ****************************************************************************}
  25.  
  26. {
  27.   possible compiler switches (* marks a currently required switch):
  28.   -----------------------------------------------------------------
  29.   BIG_ENDIAN    Target machine on which this machine will run is
  30.                 a BIG endian machine (such as the m68k)
  31. }
  32.  
  33. {$ifdef TP}
  34. {$N+,E+,G+}
  35. {$endif}
  36.  
  37. program dumpppu;
  38.  
  39.   var
  40.      f : file;
  41.      version : longint;
  42.      Filename : string;
  43.      nrfile : longint;
  44.      flags : byte;
  45.  
  46.     const
  47.        ibloadunit = 1;
  48.        iborddef = 2;
  49.        ibpointerdef = 3;
  50.        ibtypesym = 4;
  51.        ibarraydef = 5;
  52.        ibprocdef = 6;
  53.        ibprocsym = 7;
  54.        iblinkofile = 8;
  55.        ibstringdef = 9;
  56.        ibvarsym = 10;
  57.        ibconstsym = 11;
  58.        ibinitunit = 12;
  59.        ibaufzaehlsym = 13;
  60.        ibtypedconstsym = 14;
  61.        ibrecorddef = 15;
  62.        ibfiledef = 16;
  63.        ibformaldef = 17;
  64.        ibobjectdef = 18;
  65.        ibenumdef = 19;
  66.        ibsetdef = 20;
  67.        ibprocvardef = 21;
  68.        ibsourcefile = 22;
  69.        ibdbxcount = 23;
  70.        ibfloatdef = 24;
  71.        ibref = 25;
  72.        ibextsymref = 26;
  73.        ibextdefref = 27;
  74.        ibabsolutesym = 28;
  75.        ibclassrefdef = 29;
  76.        ibpropertysym = 30;
  77.        iblibraries = 31;
  78.        iblongstringdef = 32;
  79.        ibansistringdef = 33;
  80.        ibunitname      = 34;
  81.        ibwidestringdef = 35;
  82.        ibstaticlibs    = 36;
  83.        ibend = 255;
  84.  
  85.        { unit flags }
  86.        uf_init = 1;
  87.        uf_uses_dbx = 2;
  88.        uf_uses_browser = 4;
  89.        uf_in_library = 8;
  90.        uf_shared_library = 16;
  91.        uf_big_endian = 32;
  92. Type
  93.  
  94.   absolutetyp = (tovar,toasm,toaddr);
  95.  
  96.        tbasetype = (uauto,uvoid,uchar,
  97.                     u8bit,u16bit,u32bit,
  98.                     s8bit,s16bit,s32bit,
  99.                     bool8bit,bool16bit,bool32bit);
  100.  
  101.        { don't change the order of these - used to determine processor }
  102.        { taken from FPC v0.99.5 systems.pas                            }
  103.        ttarget = (target_GO32V1,target_OS2,target_LINUX,
  104.                   target_WIN32,target_GO32V2,
  105.                   target_Amiga,target_Atari,target_Mac68k);
  106.  
  107.  
  108. var abstyp : absolutetyp;
  109.     utarget : ttarget;
  110.  
  111.     function upper(const s : string) : string;
  112.       var
  113.          i  : longint;
  114.       begin
  115.          for i:=1 to length(s) do
  116.           if s[i] in ['a'..'z'] then
  117.            upper[i]:=char(byte(s[i])-32)
  118.           else
  119.            upper[i]:=s[i];
  120.          upper[0]:=s[0];
  121.       end;
  122.  
  123.   function readlong : longint;
  124.  
  125.     var
  126.        l : longint;
  127.        w1, w2: word;
  128.  
  129.     begin
  130.        blockread(f,l,4);
  131. {$ifdef BIG_ENDIAN}
  132.          w1:=l and $ffff;
  133.          w2:=l shr 16;
  134.          l:=swap(w2)+(longint(swap(w1)) shl 16);
  135. {$endif}
  136.        readlong:=l;
  137.     end;
  138.  
  139.   function readword : word;
  140.  
  141.     var
  142.        w : word;
  143.  
  144.     begin
  145.        blockread(f,w,2);
  146. {$IFDEF BIG_ENDIAN}
  147.        w:=swap(w);
  148. {$ENDIF}
  149.        readword:=w;
  150.     end;
  151.  
  152.   function readdouble : double;
  153.  
  154.     var
  155.        d : double;
  156.  
  157.     begin
  158.        blockread(f,d,8);
  159.        readdouble:=d;
  160.     end;
  161.  
  162.   function readbyte : byte;
  163.  
  164.     var
  165.        b : byte;
  166.  
  167.     begin
  168.        blockread(f,b,1);
  169.        readbyte:=b;
  170.     end;
  171.  
  172.   function readstring : string;
  173.  
  174.     var
  175.        s : string;
  176.  
  177.     begin
  178.        s[0]:=chr(readbyte);
  179.        blockread(f,s[1],ord(s[0]));
  180.        readstring:=s;
  181.     end;
  182.  
  183.   var
  184.      space : string;
  185.      read_member : boolean;
  186.  
  187.   procedure readandwriteref;
  188.  
  189.     var
  190.        w : word;
  191.  
  192.     begin
  193.        w:=readword;
  194.        if w=$ffff then
  195.          begin
  196.             w:=readword;
  197.             if w=$ffff then
  198.               writeln('nil')
  199.             else writeln('Local Definition Nr. ',w)
  200.          end
  201.        else writeln('Unit ',w,'  Nr. ',readword)
  202.     end;
  203.  
  204.   { reads the flags of a definition }
  205.   procedure readflags;
  206.  
  207.     begin
  208.        if version<13 then
  209.          readword;
  210.     end;
  211.  
  212.   var
  213.      b : byte;
  214.      unitnumber : word;
  215.  
  216.   type
  217.      tsettyp = (normset);
  218.  
  219.   procedure readin;
  220.  
  221.     var
  222.        oldread_member : boolean;
  223.        counter : word;
  224.        sourcename : string;
  225.  
  226.  
  227.     procedure read_abstract_proc_def;
  228.  
  229.        var
  230.           params : word;
  231.           options : longint;
  232.  
  233.        begin
  234.           write(space,'      Return type : ');
  235.           readandwriteref;
  236.           if Version<13 then
  237.             options:=readword
  238.           else
  239.             options:=readlong;
  240.           if options<>0 then
  241.             begin
  242.                write(space,'          Options : ');
  243.                if (options and 1)<>0 then
  244.                write('Exception handler ');
  245.                if (options and 2)<>0 then
  246.                  write('Virtual Method ');
  247.                if (options and 4)<>0 then
  248.                  write('Stack is not cleared, ');
  249.                if (options and 8)<>0 then
  250.                  write('Constructor ');
  251.                if (options and $10)<>0 then
  252.                  write('Destructor ');
  253.                if (options and $20)<>0 then
  254.                  write('Internal Procedure ');
  255.                if (options and $40)<>0 then
  256.                  write('Exported Procedure ');
  257.                if (options and $80)<>0 then
  258.                  write('I/O-Checking');
  259.                if (options and $100)<>0 then
  260.                  write('Abstract method');
  261.                if (options and $200)<>0 then
  262.                  write('Interrupt Handler');
  263.                if (options and $400)<>0 then
  264.                  write('Inline Procedure');
  265.                if (options and $800)<>0 then
  266.                  write('Assembler Procedure');
  267.                if (options and $1000)<>0 then
  268.                  write('Overloaded Operator');
  269.                if (options and $2000)<>0 then
  270.                  write('External Procedure');
  271.                if (options and $4000)<>0 then
  272.                  write('Expects parameters from left to right');
  273.                if (options and $8000)<>0 then
  274.                  write('Main Program');
  275.                if (options and $10000)<>0 then
  276.                  write('Static Method');
  277.                if (options and $20000)<>0 then
  278.                  write('Method with Override Direktive');
  279.                if (options and $40000)<>0 then
  280.                  write('Class Method');
  281.                if (options and $80000)<>0 then
  282.                  write('Unit Initialisation');
  283.                if (options and $100000)<>0 then
  284.                  write('Method Pointer (must be a procedure variable)');
  285.                writeln
  286.             end;
  287.           params:=readword;
  288.           writeln(space,'  Nr of parameters: ',params);
  289.           if params>0 then
  290.             writeln(space,'   Parameter defs : ');
  291.           while params>0 do
  292.             begin
  293.                write(space,'    Type: ',readbyte,'  ');
  294.                readandwriteref;
  295.                dec(params);
  296.             end;
  297.        end;
  298.  
  299.      var
  300.         params : word;
  301.        IgnoreEnd : Longint;
  302.  
  303.  
  304.     begin
  305.  
  306.  
  307.        counter:=0;
  308.        IgnoreEnd:=0;
  309.        repeat
  310.          b:=readbyte;
  311.  
  312.          if not (b in [ibend,ibloadunit,ibinitunit,iblinkofile,ibsourcefile,
  313.                        iblibraries,ibunitname,ibstaticlibs]) then
  314.            begin
  315.               write(space,'Definition Nr. ',counter,' : ');
  316.               inc(counter);
  317.            end;
  318.          case